#!/usr/bin/perl -w
use strict;

package SMS::Dumper;

use base qw(Exporter);
use Encode qw(decode);
use XML::WBXML qw(wbxml_to_xml);

our $VERSION = '0.01';
our @EXPORT = qw(dump_ud);
our @EXPORT_OK = qw(
    parse_ud parse_xudh dump_ud dump_ota_bitmap dump_ringtone dump_crlfdata
);

# To learn what all the abbreviations mean, read GSM 03.40.
# "xudh" is a udh without udhl

sub parse_ud {
    my ($ud) = @_;
    my ($xudh, $body) = unpack "C/a* a*", $ud;
    return $xudh, $body;
}

sub parse_xudh {
    my ($xudh) = @_;
    my @ie_flat = unpack "(C C/a*)*", $xudh;
    my @ie;
    while (@ie_flat) {
        my $ie = {};
        $ie->{iei} = shift @ie_flat;
        $ie->{ied} = shift @ie_flat;
        push @ie, $ie;
    }
    return @ie;
}

sub dump_ud {
    my ($ud) = @_;
    my ($xudh, $body) = parse_ud($ud);
    my @ie = parse_xudh($xudh);
    
    my @output;
    my $port;
    my $multipart;

    push @output, sprintf "SMS UD (UDHL=%d, UDL=%d)", length $xudh, length $ud;
    
    IE:
    for my $ie (@ie) {
        if ($ie->{iei} == 0x00) {
            my @ied = unpack "C3", $ie->{ied};
            push @output, "  IEI 00h, part of multipart message (concatenation)";
            push @output, "    Part: $ied[2] of $ied[1]";
            push @output, "    Datagram reference: " . sprintf("%02Xh", $ied[0]);
            $multipart = 1;
            next IE;
        }
        if ($ie->{iei} == 0x05) {
            my $ied = uc unpack "H*", $ie->{ied};
            my @ied = $ied =~ /(....)(....)/;
            push @output, "  IEI 05h, port specification";
            push @output, "    Destination port: $ied[0]h";
            push @output, "    Source port: $ied[1]h";
            $port = $ied[0];
            next IE;
        }
        push @output, "  Unknown IEI " . unpack("H*", $ie->{iei}) . "h";
        push @output, "    IED: " . unpack("H*", $ie->{ied}) . "h";
    }
    if (not $multipart) {
        $port ||= "crlfdata";
        if (my $dumper = __PACKAGE__->can("dump_$port")) {
            push @output, map "  $_", $dumper->($body);
        } else {
            push @output, "  Cannot dump content of this type";
        }
    } else {
        push @output, "  Not dumping partitial message content";
    }
    return @output;    
}

sub dump_ota_bitmap {
    my ($ota_bitmap) = @_;
    my ($animated, $width, $height, $depth, $bitmap) = 
        unpack "CCCCB*", $ota_bitmap;
    my @output;
    push @output, "OTA Bitmap ${width}x${height}(x${depth})";
    if ($depth == 1) {
        $bitmap =~ tr/01/ #/;
        push @output, "  /" . "-" x $width . "\\";
        push @output, map "  |$_|", unpack "(a$width)$height", $bitmap;
        push @output, "  \\". "-" x $width . "/";
    } else {
        push @output, "  Cannot dump non-monochrome bitmap"
    }
    return @output;
}

sub dump_crlfdata {
    my ($body) = @_;
    my @output;
    push @output, "/---";
    push @output, map qq[|$_], split /\x0D\x0A/, $body;
    push @output, "\\---";
    return @output; 
}

sub dump_ringtone {
    my ($body) = @_;
    # The body is NOT octet-aligned (ARGH! Punish that designer, please!)
    # and I'm lazy, so let's use strings of 0s and 1s. (The spec does this too.
    # it doesn't call 101 "5"...)
    my ($num_command_parts, $rest) = unpack "CB*", $body;
    my @output;
    push @output, "Ringtone, has $num_command_parts command parts";
    my $unicode;
    
    COMMAND_PART:
    for (1..$num_command_parts) {
        if ($rest =~ s/^0100101.//) {
            push @output, "  $_. Ringing tone programming command";
            next COMMAND_PART;
        }
        if ($rest =~ s/^0011101(...)(....)//) {
            push @output, "  $_. Sound command";
            push @output, "    Type: " . {
                "000" => "unknown (000)",
                "001" => "basic",
                "010" => "temporary",
                "011" => "MIDI",
                "100" => "digitised",
                "101" => "unknown (101)",
                "110" => "polyphonic",
                "111" => "unknown (111)",
            }->{$1};
            my $titlelen = ($unicode ? 16 : 8) * eval "0b$2";
            my $title = pack("B*", $rest =~ /(.{$titlelen})/);
            $rest =~ s///;
            $title = decode("UCS-2", $title) if $unicode;
            push @output, "    Title: \"$title\"";
            # And the rest of the data, we just ignore :)
            last COMMAND_PART;
        } 
        if ($rest =~ s/^0000101//) {
            push @output, "  $_. Cancel command";
            next COMMAND_PART;
        } 
        if ($rest =~ s/^0100010//) {
            push @output, "  $_. Unicode command";
            $unicode = 1;
            next COMMAND_PART;
        }
        push @output, "  $_. Unknown command part, cannot process further";
        push @output, "    Command: " . substr $rest, 0, 7;
        last COMMAND_PART;
    }
    return @output;
}

sub dump_wbxml {
    my ($wbxml) = @_;
    my $xml = wbxml_to_xml($wbxml);
    my $width = 72;  # arbitrary
    my @output;
    push @output, "XML Data (If just a number, parsing failed)";
    push @output, "  /" . "-"x$width . "\\";
    $xml .= " " x ($width - length($xml) % $width);
    push @output, map "  |$_|", unpack "(a$width)*",$xml;
    push @output, "  \\". "-"x$width . "/";
    return @output;
}

sub dump_C34F {
    my ($body) = @_;
    my @output;
    push @output, "OTA settings/bookmarks provisioning";
    # TODO - eh, everything.
    return @output;
}

sub dump_C34D {
    return "PoC (Push to talk over Cellular)", map "  $_", dump_wbxml(shift);
}

sub dump_23F4 {
    return "VCard", map "  $_", dump_crlfdata(shift);
}

sub dump_23F5 {
    return "VCalendar", map "  $_", dump_crlfdata(shift);
}

sub dump_158A {
    my ($body) = @_;
    my ($version, @items) = unpack "a (C n/a)*", $body;
    my @output;
    push @output, "Profile or picture message";
    push @output, "  Version: $version";
    while (@items) {
        my $type = shift @items;
        my $data = shift @items;
        if ($type == 0x00) {
            push @output, "  Text";
            push @output, map "    $_", dump_crlfdata($data);
        } elsif ($type == 0x02) {
            push @output, map "  $_", dump_ota_bitmap($data);
        } elsif ($type == 0x03) {
            push @output, map "  $_", dump_ringtone($data);
        } elsif ($type == 0x04) {
            push @output, "  Profile name: \"$data\"";
        } elsif ($type == 0x06) {
            my @bitmap = dump_ota_bitmap($data);
            push @output, "  Screensaver - " . shift @bitmap;
            push @output, map "  $_", @bitmap;
        } else {
            push @output, "  Unknown item type (" . uc(unpack "H*", $type) . "h)";
        }
    }
    return @output;
}

sub dump_1583 {
    my ($body) = @_;
    my ($version, $ota_bitmap) = unpack "aa*", $body;
    my @output;
    push @output, "CLI icon";
    push @output, "  Version: $version";
    push @output, map "  $_", dump_ota_bitmap($ota_bitmap);
    return @output;
}

sub bcd_decode($) {
    my ($in) = @_;
    my $res = '';
    foreach my $nybble (split(//, $in)) {
        if ($nybble =~ /[0-9]/) {
            $res .= "$nybble";
        }
    }
    return $res;
}

sub dump_1582 {
    my ($body) = @_;
    my ($version, $mmc, $mnc, $ota_bitmap) = unpack "a h4 h2 x a*", $body;
    $mmc = bcd_decode($mmc);
    $mnc = bcd_decode($mnc);
    my @output;
    push @output, "Operator logo";
    push @output, "  Version: $version";
    push @output, "  Operator: \Ummc = $mmc\E, \Umnc = $mnc\E";
    push @output, map "  $_", dump_ota_bitmap($ota_bitmap);
    return @output;
}

sub dump_1581 {
    return dump_ringtone(shift);
}

sub dump_0B84 {
    my ($body) = @_;
    my ($trans_id, $pdu_type, $headers, $wbxml) = unpack "CC C/a* a*", $body;
    # TODO interpret headers. XXX Are headers really C/a*, not w/a*?
    my @output;
    push @output, "WAP Push message";
    push @output, "  Transaction ID: $trans_id";
    push @output, "  PDU Type: $pdu_type";
    push @output, map "  $_", dump_wbxml($wbxml);
    return @output;
}


1;

__END__

=head1 NAME

SMS::Dumper - Dump UDH-based SMS messages to ease debugging

=head1 SYNOPSIS

    use SMS::Dumper;
    print map "$_\n", dump_ud($ud);

=head1 DESCRIPTION

SMS messages are not always simple 7 bit text. They can also be binary data.
This module helps understand that data by dumping information found in it.

Such binary SMS messages typically carry a UDH, which begins with a UDHL, a
single byte indicating the UDH size, excluding this size indicator. To the
existing terminology, this module adds I<XUDH>, which is a UDH without its
UDHL.

For explanation of terminology, see the GSM 03.40 specification.

=head2 dump_ud($ud)

Parses and dumps the UD content. The UD is expected to include a UDH at the
beginning; if there is no UDH, you could prefix "\0", which is a UDHL of 0,
followed by a XUDH of 0 bytes.

Returns a list of lines without line ending characters.

Exported by default.

=head2 parse_ud

Given a UD, returns a 2-element list of XUDH and body.

=head2 parse_xudh

Given an XUDH, returns a list of IEs, expressed as C<< { iei => number, ied =>
string } >>.

=head2 dump_ota_bitmap

Given an OTA Bitmap string (with B<4> bytes of header data before the picture
data), returns a list of lines without line ending characters.

=head2 dump_ringtone

Given a ringtone string (if you know what this format is called, let me know.),
returns a lis of lines without line ending characters.

=head1 SUPPORTED PORTS

Unsplit messages are dumped in more detail if this module knows how to do so.
This is done with C<dump_xxxx> subs found in C<SMS::Dumper>, where C<xxxx> is
the uppercase hex destination port number. For an overview, refer to the source
of this module.

Code/patches for supporting additional applications is very much welcome!

=head1 AUTHOR

Juerd <juerd@cpan.org>

=head1 LICENSE

Copyright (c) 2006, Blinck International B.V.
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following
conditions are met:

Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.

Redistributions in binary form must reproduce the above copyright notice,
this list of conditions and the following disclaimer in the documentation
and/or other materials provided with the distribution.

Neither the name of the Blinck International B.V. nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.


THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.


